﻿module CPFD.Samples.Sudoku

open CPFD.Monad
open CPFD.Core

// ref: http://stackoverflow.com/questions/3016139/help-me-to-explain-the-f-matrix-transpose-function
let rec transpose = function
    | (_::_)::_ as M -> List.map List.head M :: transpose (List.map List.tail M)
    | _ -> []    

// ref: http://fsharpcode.blogspot.com/2010/03/splitevery-chunk.html
let rec chunk n xs = 
    let splitAt n (xs:#seq<'a>) = (Seq.take n xs |> Seq.toList, Seq.skip n xs |> Seq.toList)
    match xs with
    | [] -> []
    | _ ->
        let ys, zs = splitAt n xs 
        ys :: chunk n zs

let rows xs = chunk 9 xs
let columns xs = xs |> rows |> transpose
let boxes xs =     
    let box (xa : array<'a>) bi bj : list<'a> =
        [        
            for j in 0..2 do
                let r = bj*3 + j
                for i in 0..2 do
                    let c = bi*3 + i
                    yield xa.[r*9+c]
        ]
    [
        let xa = Array.ofList xs
        for bj in 0..2 do
            for bi in 0..2 do
            yield box xa bi bj                            
    ]

//////////////////////////////////////////////////////////////////////////////////////
// Sudoku solver
// 
// Ref: http://overtond.blogspot.com/2008/07/haskell-sudoku-solver-using-finite.html
//////////////////////////////////////////////////////////////////////////////////////
module Solver =
    type Puzzle = int list

    let test : Puzzle = [
        0; 0; 0; 0; 8; 0; 0; 0; 0;
        0; 0; 0; 1; 0; 6; 5; 0; 7;
        4; 0; 2; 7; 0; 0; 0; 0; 0;
        0; 8; 0; 3; 0; 0; 1; 0; 0;
        0; 0; 3; 0; 0; 0; 8; 0; 0;
        0; 0; 5; 0; 0; 9; 0; 7; 0;
        0; 5; 0; 0; 0; 8; 0; 0; 6;
        3; 0; 1; 2; 0; 4; 0; 0; 0;
        0; 0; 6; 0; 1; 0; 0; 0; 0 ];

    // Solution:
    //[5,6,7,4,8,3,2,9,1]
    //[9,3,8,1,2,6,5,4,7]
    //[4,1,2,7,9,5,3,6,8]
    //[6,8,9,3,7,2,1,5,4]
    //[7,4,3,6,5,1,8,2,9]
    //[1,2,5,8,4,9,6,7,3]
    //[2,5,4,9,3,8,7,1,6]
    //[3,7,1,2,6,4,9,8,5]
    //[8,9,6,5,1,7,4,3,2]
              
    let sudoku (puzzle : Puzzle) = cp {
            let! vars = newVars 81 [1..9]
            do! cp.zipWithM_ (fun x n -> cp { if n > 0 then do! hasValue x n }) vars puzzle
            do! cp.mapM_ allDifferent (rows vars)
            do! cp.mapM_ allDifferent (columns vars)
            do! cp.mapM_ allDifferent (boxes vars)
            return! labelling vars
        }

    let run = 
        let result = runFD (sudoku test)
        for r in result do
            r |> rows |> List.map (fun row -> printf "%A\n" row) |> ignore
            printf "-----------\n"

//////////////////////////////////////////////////////////////////////////////////////
// Sudoku generator
//
// ref: http://www.math.washington.edu/~morrow/mcm/team2280.pdf
//////////////////////////////////////////////////////////////////////////////////////
module Generator =

    // Latin squares ////////////////////////////////////////

    let latinSquaresConstraints = 
        let rows xs = chunk 3 xs
        let columns xs = xs |> rows |> transpose    
        cp {
            let! vars = newVars 9 [0..2]
            do! cp.mapM_ allDifferent (rows vars)
            do! cp.mapM_ allDifferent (columns vars)
            return! labelling vars
        }

    let latinSquares = runFD latinSquaresConstraints |> List.map Array.ofList

    // Generator //////////////////////////////////////////////
        
    open CPFD.Utils

    type GeneratorState = { solution: list<int>; board : list<int>; triedGivens : list<int>; untriedGivens : list<int> }

    let createRandomSolution() =
        let convertToBase10 (main : array<int>, grids : list<array<int>>) =
            [ for r in 0..8 do
                for c in 0..8 do
                    let mainRow, mainCol = r / 3, c / 3
                    let grid = List.nth grids (mainRow * 3 + mainCol)
                    let gridRow, gridCol = r % 3, c % 3
                    let highBit = main.[mainRow * 3 + mainCol]
                    let lowBit = grid.[gridRow * 3 + gridCol]
                    yield highBit * 3 + lowBit + 1
            ]

        // Swap the 2nd & 4th rows, 3rd & 7th rows, and 6th & 8th rows preserving the row and column properties
        let swapRows board = 
            match board |> rows with
            | [r1;r2;r3;r4;r5;r6;r7;r8;r9] -> [r1;r4;r7;r2;r5;r8;r3;r6;r9] |> List.concat
            | _ -> raise(System.ArgumentException())
        
        List.selectRandom 10 latinSquares |> 
        (fun x -> Seq.head x, Seq.toList(Seq.skip 1 x)) |>
        convertToBase10 |> 
        swapRows
    
    let hasUniqueSolution board = 
        let solutions = runFD (Solver.sudoku board)
        List.length solutions = 1

    let difficultyAcceptable board = 
        let numgiven = board |> List.filter (fun x -> x <> 0) |> List.length
        numgiven < 28

    let rec generate() =
        printf "Generating sudoku...\n" 
        let randomSolution = createRandomSolution();
        List.iter (fun x -> printf "%A\n" x) (rows randomSolution)
        initialize { solution = randomSolution; board = []; triedGivens = []; untriedGivens = [] }

    and initialize (state : GeneratorState) =
        let given = List.selectRandom 40 [0..80]
        let board = [ let givenSet = Set.ofList given
                      for i in 0..80 do 
                        if Set.contains i givenSet then
                            yield List.nth state.solution i
                        else
                            yield 0 ]    
        if hasUniqueSolution board then
            removeGivens { state with board = board; triedGivens = []; untriedGivens = List.randomize given }
        else 
            initialize(state)

    and removeGivens (state : GeneratorState) =    
        match state.untriedGivens with
        | [] -> initialize state
        | p::ps -> 
            printf "." 
            let board' = List.set p 0 state.board
            let state' = { state with triedGivens = p :: state.triedGivens; untriedGivens = ps }
            if hasUniqueSolution board' then
                if difficultyAcceptable board' then
                    board'
                else
                    printf "C"
                    removeGivens { state' with board = board' }         
            else
                removeGivens state'

    let run = 
        let mutable ok = true                 
        while ok do
            let game = generate() 
            printf "\n"
            game |> rows |> List.iter (fun x -> printf "%A\n" x)
            printf "------ press anu key to continue... (q to quite)"
            ok <- System.Console.ReadLine() <> "q"
